﻿Imports System.Math

Public Class Numberlink
    Inherits Puzzle

    Public Sub New()
        AvailableSizes = Range(5, 12)
        Size = 10
    End Sub


    Public Overrides Sub DrawCell(ByVal e As DrawCellArgs)
        Dim R = e.Cell.Rect
        Fill(e.Cell, 2)
        If e.Cell.bg > 0 Then
            Gfx.FillRectangle(New SolidBrush(Color.FromArgb(64, Color.FromArgb(QBColor(e.Cell.bg)))), e.Cell.Rect)
        End If
        If e.Cell.f <> "" Then
            For Each n In e.Cell.Sides
                If e.Cell.f = n.f Or e.Cell.f = n.g Then
                    Dim cx = R.Left + R.Width \ 2
                    Dim cy = R.Top + R.Height \ 2
                    If n.x = e.Cell.x - 1 Then Gfx.DrawLine(New Pen(Brushes.OrangeRed, 3), cx, cy, R.Left, cy)
                    If n.x = e.Cell.x + 1 Then Gfx.DrawLine(New Pen(Brushes.OrangeRed, 3), cx, cy, R.Right, cy)
                    If n.y = e.Cell.y - 1 Then Gfx.DrawLine(New Pen(Brushes.OrangeRed, 3), cx, cy, cx, R.Top)
                    If n.y = e.Cell.y + 1 Then Gfx.DrawLine(New Pen(Brushes.OrangeRed, 3), cx, cy, cx, R.Bottom)
                End If
            Next
        End If
        If e.Cell.g <> "" Then
            DrawGiven(e.Cell, e.Cell.g, e.Invert)
        Else
            DrawGiven(e.Cell, Chr(149), e.Invert)
        End If
    End Sub

    Public Overrides Function OnKeyPress(ByVal Key As String) As Boolean
        Select Case Key
            Case "A" To "M", "a" To "m"
                If Len(Key) = 1 Then CursorCell.g = Key.ToUpper Else Return MyBase.OnKeyPress(Key)
            Case Else
                Return MyBase.OnKeyPress(Key)
        End Select
    End Function

    Public Overrides Sub Load(ByVal Data As String)
    End Sub

    Public Overrides Function Save() As String
        Return ""
    End Function

    Public Overrides Sub Solve()
        For Each Cell In Cells
            Cell.Reset("")
        Next
        ProcessGivens()
        For Each Cell In Cells
            If Cell.f <> "" Then
                Cell.Candidates = Cell.f.ToCharArray.ToList
                Cell.f = ""
            Else
                Cell.Candidates = (From c In Cells Where c.g <> "" Select c.g.ToCharArray.First).Distinct.ToList
            End If
        Next

        Dim Solutions As New List(Of Cells)
        Dim ch = "A"
        max = ""
        FindPattern(ch, Solutions)
        Invalidate()
    End Sub

    Sub ProcessGivens()
        Do
            Dim Found = False
            For Each r In From c In Cells.Givens Where (From n In c.Sides Where Not n.Given And n.f = c.g).Count = 0 And c.Sides.Empties.Count = 1 Let f = c.Sides.Empties.First
                r.f.f = r.c.g
                Found = True
            Next
            For Each r In From c In Cells.Founds Where c.Sides.Empties.Count = 1 And (From n In c.Sides Where ((n.g = "" And n.f = c.f) Or (c.f = n.g))).Count = 1 Let f = (From n In c.Sides Where Not n.Given And n.f = "").First
                r.f.f = r.c.f
                Found = True
            Next
            For Each r In From c In Cells.Empties Where c.Sides.Count = 2 And c.Sides.Givens.Count = 1 Let f = c.Sides.Givens.First
                r.c.f = r.f.g
                Found = True
            Next
            For Each r In From c1 In Cells.Givens From c2 In Cells.Givens Where c1 > c2 AndAlso c1.g = c2.g AndAlso c1.Sides.Count < 4 AndAlso c2.Sides.Count < 4
                For i = 1 To 2
                    Dim Cell = r.c1
                    Dim Path As New Cells
                    Dim dy As Integer = If(Cell.x = 1 Or Cell.x = Size, If(i = 1, 1, -1) * If(Cell.x = 1, -1, 1), 0)
                    Dim dx As Integer = If(Cell.y = 1 Or Cell.y = Size, If(i = 1, 1, -1) * If(Cell.y = 1, 1, -1), 0)
                    Do
                        Path.Add(Cell)
                        If Cell Is r.c1 AndAlso Path.Count > 1 Then Exit Do
                        If Cell Is r.c2 Then
                            For Each c In Path
                                c.Candidates = r.c1.g.ToCharArray.ToList
                            Next
                            Exit Do
                        ElseIf Cell.g > "" And Cell.g <> r.c1.g Then
                            Exit Do
                        Else
                            If (Cell.x = 1 Or Cell.x = Size) And (Cell.y = 1 Or Cell.y = Size) Then
                                If dy = 0 Then
                                    dy = If(i = 1, 1, -1) * dx : dx = 0
                                Else
                                    dx = If(i = 1, -1, 1) * dy : dy = 0
                                End If
                            End If
                            If Find(Cell.x + dx, Cell.y + dy) is Nothing then stop
                            Cell = Find(Cell.x + dx, Cell.y + dy)
                        End If
                    Loop
                Next
            Next
            If Not Found Then Exit Do
        Loop
    End Sub

    Dim max = ""
    Function FindPattern(ByVal ch As Char, ByVal Solutions As List(Of Cells)) As Boolean
        If ch <> "A" Then If Not CheckAvail2(Chr(Asc(ch) - 1), Nothing, True) Then Exit Function
        If ch >= max Then
            max = ch
            Invalidate()
            Application.DoEvents()
        End If
        Dim Cell1 = (From c In Cells Where c.g = ch).FirstOrDefault
        If Cell1 Is Nothing Then Return True
        Dim Cell2 = (From c In Cells Where c.g = ch).LastOrDefault
        Dim History = New Stack(Of Cell)
        Dim a = (From c1 In Cells.Givens Where c1.g > ch From c2 In Cells.Givens Where c2.g = c1.g AndAlso c1 > c2 Select Math.Abs(c1.x - c2.x) + Math.Abs(c1.y - c2.y)).Sum
        Dim maxlength = (From c In Cells Where c.f = "").Count - a
        Cell1.f = Cell1.g
        If TryCell(ch, Cell1, Nothing, Cell2, History, Solutions, maxlength) Then Return True
        Cell1.f = ""
    End Function

    Function TryCell(ByVal ch As Char, ByVal Current As Cell, ByVal Prev As Cell, ByVal Target As Cell, ByVal History As Stack(Of Cell), ByVal Solutions As List(Of Cells), ByVal MaxLength As Integer) As Boolean
        If History.Count + If(Prev Is Nothing, 0, 1) + Math.Abs(Current.x - Target.x) + Math.Abs(Current.y - Target.y) > MaxLength Then Return False
        'Break()
        'If Not CheckAvail2(ch, Current, False) Then Exit Function
        'If (From c In Cells.Givens Where c.g <> ch And Not c.LateralNeighbours.Empties.Any).Any Then Exit Function
        If Current Is Target Then
            History.Push(Prev)
            History.Push(Current)
            Current.f = ch
            Dim res = FindPattern(Chr(Asc(ch) + 1), Solutions)
            If Not res Then
                History.Pop()
                History.Pop()
                Current.f = ""
            End If
            Return res
            Exit Function
        End If
        If Not Prev Is Nothing Then History.Push(Prev)
        Dim Candidates As New Cells(
            From c In Current.Sides.Empties.Except(History)
            Where c.Candidates.Contains(ch) AndAlso
            Not (From cc In History From ccc In cc.Sides Select ccc).Contains(c))
        If Current.Sides.Contains(Target) Then Candidates = New Cells : Candidates.Add(Target)
        For Each Cell In Candidates
            Dim OK As Boolean = True
            Cell.f = ch
            If OK Then
                If History.Count >= 3 Then
                    Dim C2 = History(2)
                    If Cell.DistanceFrom(C2) = 2 Then
                        Dim MC = Find((Cell.x + C2.x) / 2, (Cell.y + C2.y) / 2)
                        If MC.g = "" Then OK = False
                    End If
                End If
            End If
            If OK Then
                If History.Count >= 4 Then
                    Dim C2 = History(3)
                    If Cell.DistanceFrom(C2) = 3 Then
                        Dim C1 = Cell
                        Dim MC = (From c In Cells Where ((C1.x = C2.x AndAlso c.x = C1.x AndAlso c.y.StandsBetween(C1.y, C2.y)) OrElse (C1.y = C2.y AndAlso c.y = C1.y AndAlso c.x.StandsBetween(C1.x, C2.x))) AndAlso c.g = "")
                        If MC.Count = 2 Then OK = False
                    End If
                End If
            End If
            If OK Then
                Dim dd = (From c In Cells.Empties Where c.Sides.Count = 3 AndAlso (From n In c.Sides Where n.f = "").Count <= 1 AndAlso (From n In c.Sides Where n.f <> "" Select n.f).Distinct.Count = 1)
                If dd.Any Then OK = False
            End If
            If OK Then
                Dim dd = (From c In Cells.Empties Where c.Sides.Count = 2 AndAlso Not (From n In c.Sides Where n.g <> " ").Any AndAlso (From n In c.Sides Where n.f = "").Count = 0)
                If dd.Any Then OK = False
            End If
            If OK Then
                If TryCell(ch, Cell, Current, Target, History, Solutions, MaxLength) Then Return True
            End If
            Cell.f = ""
        Next
        If History.Count > 0 Then History.Pop()
    End Function

    Function CheckAvail2(ByVal cht As String, ByVal Current As Cell, ByVal FullCheck As Boolean) As Boolean
        Dim Areas As New List(Of Cells)
        For Each c In Cells
            c.bg = 0
        Next
        Do
            Dim Cell = (From c In Cells Where c.f = "" And Not (From a In Areas Where a.Contains(c)).Any).FirstOrDefault
            If Cell Is Nothing Then Exit Do
            Dim Area As New Cells
            FillArea(Cell, Area)
            Areas.Add(Area)
        Loop
        'If FullCheck Then
        'For Each r In From a In Areas From c In a Select c, col = Areas.IndexOf(a) + 1
        '    r.c.bg = r.col
        'Next
        'Break()
        'End If
        Dim Pairs = From a In Areas From c In a.Givens Where c.g > cht Group By a, c.g Into s = Count()

        'Bölgelerde tek kalan harf var ise
        If (From p In Pairs Where p.s = 1).Any Then Return False

        'Tamamen boş bölgeler
        If (From a In Areas Where a.Givens.Count = 0).Any Then Return False

        'İki farklı harf arasında sıkışan boş bölge
        Dim u3 = From a In Areas From c In Cells Where c.f = "" Let k = c.Sides.Intersect(a) Where k.Count = 2 Where k(0).Given And k(1).Given And k(0).g <> k(1).g And k(0).g <> cht And k(1).g <> cht
        If u3.Any Then Return False

        'Tek komşusu kalan bir harfin komşusunun faklı bir harf olmaması durumu
        Dim u6 = From a In Areas From c In a.Givens(cht) Where c.Sides.Intersect(a).Count = 1 Let n = c.Sides.Intersect(a).First Where n.g <> "" And n.g <> c.g
        If u6.Any Then Return False

        'Tek komşusu kalan bir boş hücre olması durumu
        Dim u2 = (From a In Areas From c In a.Except(If(FullCheck, New Cells, Current.Sides)) Where c.g = "" AndAlso c.Sides.Intersect(a).Count = 1)
        If u2.Any Then Return False

        'Tek hücreli bölge olma durumu
        Dim u1 = (From a In Areas Where a.Count = 1 AndAlso Not Current.Sides.Contains(a.First))
        If u1.Any Then Return False

        'Tek harf olan bölgelerde blok boşluk olma durumu
        Dim u5 = (From p In Pairs Where Not p.a.Intersect(If(Current Is Nothing, New Cells, Current.Sides)).Any Group By a = p.a Into k = Count() Where k = 1 From c In a Where c.Sides.Intersect(a).Count = 3)
        If u5.Any Then Return False

        '4 boş hücreden oluşan bir karedeki hücrelerin kenarlara gelmesi durumu
        If FullCheck Then
            Dim u7 = (From a In Areas
                    From c1 In a.Empties Let c1n = c1.Sides.Intersect(a) Where c1n.Count = 2
                    From c2 In c1n Where c2.g = "" AndAlso c1 > c2 Let c2n = c2.Sides.Intersect(a) Where c2n.Count = 2
                    Where (From c In c1n Where c IsNot c2).First.Sides.Contains((From c In c2n Where c IsNot c1).First))
            If u7.Any Then
                'For Each r In u7
                '    r.c1.bg = 12
                '    r.c2.bg = 12
                'Next
                'Break()
                Return False
            End If
        End If

        'Darboğazlar
        Dim d1 = (From a In Areas From c In a Where c.f = ""
                 Let k = c.Sides.Intersect(a) Where k.Count = 2
                 Let c1 = k(0), c2 = k(1) Where (c1.x = c2.x OrElse c1.y = c2.y) Select a, c, c1, c2)
        Dim d2 = (From a In Areas From c In a Where c.f = ""
                 Let k = c.Neighbours.Except(a) Where k.Count.Between(2, 3)
                 Where Abs(k(0).x - k(1).x) + Abs(k(0).y - k(1).y) > 2
                 Let cc1 = Find(c.x - 1, c.y - 1), cc2 = Find(c.x + 1, c.y + 1), cc3 = Find(c.x + 1, c.y - 1), cc4 = Find(c.x - 1, c.y + 1)
                 Select a, c, c1 = If(a.Contains(cc1) And a.Contains(cc2), cc1, cc3), c2 = If(a.Contains(cc1) And a.Contains(cc2), cc2, cc4)
                 )
        Dim df = d1.Union(d2)
        If df.Any Then
            Dim dfr = From u In df Where Not (From v In df Where u.c.Sides.Contains(v.c) AndAlso u.a Is v.a AndAlso u.c < v.c).Any
            'Break()
            For Each c In dfr
                If Not CheckBottleneck(c.c, c.a, c.c1, c.c2, cht, FullCheck, Current) Then
                    Return False
                End If
            Next
            For Each c In dfr
                c.c.bg = 14
                c.c1.bg = 13
                c.c2.bg = 13
            Next
            'Invalidate()
            'Application.DoEvents()
            'Break()
        End If
        Return True
    End Function

    Sub FillArea(ByVal Cell As Cell, ByVal Area As Cells)
        Area.Add(Cell)
        For Each r In From c In Cell.Sides Where c.f = "" AndAlso Not Area.Contains(c)
            FillArea(r, Area)
        Next
    End Sub

    Function CheckBottleneck(ByVal Anchor As Cell, ByVal AreaChecked As Cells, ByVal Cell1 As Cell, ByVal Cell2 As Cell, ByVal cht As String, ByVal FullCheck As Boolean, ByVal Current As Cell) As Boolean
        Dim Areas As New List(Of Cells)
        For i = 0 To 1
            Areas.Add(New Cells)
            FillArea(If(i = 0, Cell1, Cell2), Areas(i), Cells, Anchor)
        Next
        If Areas(0).Intersect(Areas(1)).Count > 0 Then Return True
        'For Each r In From a In Areas From c In a Select c, col = Areas.IndexOf(a) + 1
        '    r.c.bg = r.col
        'Next
        'break
        If FullCheck Then
            Dim u2 = (From a In Areas From c In a Where c.g = "" AndAlso Not c.Sides.Contains(Anchor) AndAlso c.Sides.Intersect(a).Count = 1)
            If u2.Any Then Return False
        End If
        Dim Pairs = From a In Areas From c In a.Givens(cht) Group By a, c.g Into s = Count()
        If (From p In Pairs Where p.s = 1 Group By p.a Into c = Count() Where c > 1).Any Then Return False
        If FullCheck AndAlso (From a In Areas Where a.Givens(cht).Count = 0).Any Then Return False

        'Tek harf olan bölgelerde blok boşluk olma durumu
        If FullCheck Then
            Dim u5 = (From p In Pairs Where Not p.a.Intersect(If(Current Is Nothing, New Cells, Current.Sides)).Any
                      Group By a = p.a Into k = Count() Where k = 1
                      From c In a Where c.Sides.Intersect(a).Count = 3)
            If u5.Any Then Return False
        End If

        '***
        'If FullCheck Then
        '    For Each r In (From a In Areas Where a.Givens(cht).Count = 1)
        '        If (From c In r Where c.LateralNeighbours.Intersect(r).Count > 2).Any Then Return False
        '    Next
        'End If
        'For Each r In From a In Areas From c In a Select c, col = Areas.IndexOf(a) + 1
        '    r.c.bg = r.col
        'Next
        'break
        Return True
    End Function

    Sub FillArea(ByVal Cell As Cell, ByVal Area As Cells, ByVal Cells As Cells, ByVal AnchorCell As Cell)
        Area.Add(Cell)
        For Each r In From c In Cell.Sides.Intersect(Cells) Where c.f = "" AndAlso Not Area.Contains(c) AndAlso Not c Is AnchorCell
            FillArea(r, Area, Cells, AnchorCell)
        Next
    End Sub

End Class

